home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 25: Programming / pc_actual_25.iso / Delphi / Duck Report / _SETUP.1 / DBarQrp.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-10-23  |  8.2 KB  |  297 lines
  1. Unit DBarQrp;
  2.  
  3. Interface
  4.  
  5. Uses
  6.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  7.     DSGNINTF, Dialogs, DBarcode, DB, QuickRpt;
  8. Type
  9.  
  10.     { ---------- TQRDuckBarcode ---------- }
  11.     TQRDuckBarcode = Class (TQRPrintable)
  12.   Private
  13.   Protected
  14.       FBarcode:    TDuckBarcode;
  15.         FPicture:    TPicture;
  16.      FDataField:    String;
  17.      FDataSet:    TDataSet;
  18.  
  19.      Procedure    SetStyle (Const Value: TBarcodeStyle);
  20.      Function        GetStyle: TBarcodeStyle;
  21.      Procedure    SetRotation (Const Value: TBarcodeRotation);
  22.      Function        GetRotation: TBarcodeRotation;
  23.      Procedure    SetAddOn (Const Value: String);
  24.      Function        GetAddOn: String;
  25.      Procedure    SetHeightMM (Const Value: Double);
  26.      Function        GetHeightMM: Double;
  27.      Procedure    SetColor (Const Value: TColor);
  28.      Function        GetColor: TColor;
  29.      Procedure    SetColorBK (Const Value: TColor);
  30.      Function        GetColorBK: TColor;
  31.      Procedure    SetFont (Const Value: TFont);
  32.      Function        GetFont: TFont;
  33.      Procedure    SetAlignment (Const Value: TAlignment);
  34.      Function        GetAlignment: TAlignment;
  35.      Procedure    SetBarWidth (Const Value: Double);
  36.      Function        GetBarWidth: Double;
  37.      Procedure    SetOptions (Const Value: TBarcodeOptions);
  38.      Function        GetOptions: TBarcodeOptions;
  39.  
  40.      Procedure    SetPicture (Value: TPicture);
  41.      Procedure    Paint; Override;
  42.   Public
  43.       Constructor    Create(owner: TComponent); Override;
  44.         Destructor    Destroy; Override;
  45.      Property        Barcode:    TDuckBarcode Read FBarcode;
  46.      Procedure    Print (OfsX, OfsY : integer); override;
  47.      property        Picture: TPicture read FPicture write SetPicture;
  48.   Published
  49.       Property Alignment:    TAlignment Read GetAlignment Write SetAlignment;
  50.         Property Style:        TBarcodeStyle Read GetStyle Write SetStyle;
  51.      Property Rotation:    TBarcodeRotation Read GetRotation Write SetRotation;
  52.      Property AddOn:        String Read GetAddOn Write SetAddOn;
  53.      Property HeightMM:    Double Read GetHeightMM Write SetHeightMM;
  54.      Property ColorBar:    TColor Read GetColor Write SetColor;
  55.      Property ColorBK:        TColor Read GetColorBK Write SetColorBK;
  56.      Property Font:            TFont Read GetFont Write SetFont;
  57.      Property BarWidthMM:    Double Read GetBarWidth Write SetBarWidth;
  58.      Property Options:        TBarcodeOptions Read GetOptions Write SetOptions
  59.                                  Default [boShowText, boCheckCRC];
  60.  
  61.      Property Color;
  62.      Property DataField:    String read FDataField write FDataField;
  63.      Property DataSet:     TDataSet read FDataSet write FDataSet;
  64.     End;
  65.  
  66.   { ---------- TQRBarcodeFieldProperty ---------- }
  67.   TQRBarcodeFieldProperty = Class(TStringProperty)
  68.     Public
  69.         Procedure    GetValues(Proc: TGetStrProc); Override;
  70.         Function        GetAttributes: TPropertyAttributes; Override;
  71.     End;
  72.  
  73. Procedure Register;
  74.  
  75. Implementation
  76. {$R DBarQrp.res}
  77. Procedure Register;
  78. Begin
  79.     RegisterComponents('DuckTech', [TQRDuckBarcode]);
  80.     RegisterPropertyEditor (TypeInfo(String), TQRDuckBarcode, 'DataField',
  81.         TQRBarcodeFieldProperty);
  82. End;
  83.  
  84. { ---------- TQRBarcodeFieldProperty ---------- }
  85. Function TQRBarcodeFieldProperty.GetAttributes : TPropertyAttributes;
  86. Begin
  87.   Result := [paValueList, paSortList];
  88. End;
  89. Procedure TQRBarcodeFieldProperty.GetValues(Proc: TGetStrProc);
  90. Var
  91.     i:                    Integer;
  92.   QRDuckBarcode:    TQRDuckBarcode;
  93. Begin
  94.     if not (GetComponent(0) is TQRDuckBarcode) Then Exit;
  95.     QRDuckBarcode    := TQRDuckBarcode (GetComponent(0));
  96.   if QRDuckBarcode.DataSet = nil Then Exit;
  97.     For i := 0 To QRDuckBarcode.DataSet.FieldCount - 1 Do
  98.     Begin
  99. //      if QRDuckBarcode.DataSet.Fields[i].Visible Then
  100.         Proc (QRDuckBarcode.DataSet.Fields[i].FieldName);
  101.     End;
  102. End;
  103.  
  104. { ---------- TQRDuckBarcode ---------- }
  105. Constructor TQRDuckBarcode.Create(owner: TComponent);
  106. Begin
  107.     inherited Create(owner);
  108.     FBarcode    := TDuckBarcode.Create (Self);
  109.   FBarcode.Text        := '0123456789012';
  110.   FBarcode.Density    := 1;
  111.  
  112.   FPicture := TPicture.Create;
  113.   Color        := clWhite;
  114. End;
  115. Destructor TQRDuckBarcode.Destroy;
  116. Begin
  117.     FPicture.Free;
  118.     FBarcode.Free;
  119.   inherited Destroy;
  120. End;
  121. Procedure TQRDuckBarcode.SetStyle (Const Value: TBarcodeStyle);
  122. Begin
  123.     FBarcode.Style    := Value;
  124.   Picture.Graphic    := FBarcode.GetBitmap;
  125.     Invalidate;
  126. End;
  127. Function TQRDuckBarcode.GetStyle: TBarcodeStyle;
  128. Begin
  129.     Result    := FBarcode.Style; 
  130. End;
  131. Procedure TQRDuckBarcode.SetRotation (Const Value: TBarcodeRotation);
  132. Begin
  133.     FBarcode.Rotation    := Value;
  134.   Picture.Graphic    := FBarcode.GetBitmap;
  135.     Invalidate;
  136. End;
  137. Function TQRDuckBarcode.GetRotation: TBarcodeRotation;
  138. Begin
  139.     Result    := FBarcode.Rotation;
  140. End;
  141. Procedure TQRDuckBarcode.SetAddOn (Const Value: String);
  142. Begin
  143.     FBarcode.AddOn    := Value;
  144.   Picture.Graphic    := FBarcode.GetBitmap;
  145.     Invalidate;
  146. End;
  147. Function TQRDuckBarcode.GetAddOn: String;
  148. Begin
  149.     Result    := FBarcode.AddOn;
  150. End;
  151. Procedure TQRDuckBarcode.SetHeightMM (Const Value: Double);
  152. Begin
  153.     FBarcode.HeightMM    := Value;
  154.   Picture.Graphic    := FBarcode.GetBitmap;
  155.     Invalidate;
  156. End;
  157. Function TQRDuckBarcode.GetHeightMM: Double;
  158. Begin
  159.     Result    := FBarcode.HeightMM;
  160. End;
  161. Procedure TQRDuckBarcode.SetColor (Const Value: TColor);
  162. Begin
  163.     FBarcode.ColorBar    := Value;
  164.   Picture.Graphic    := FBarcode.GetBitmap;
  165.     Invalidate;
  166. End;
  167. Function TQRDuckBarcode.GetColor: TColor;
  168. Begin
  169.     Result    := FBarcode.ColorBar;
  170. End;
  171. Procedure TQRDuckBarcode.SetColorBK (Const Value: TColor);
  172. Begin
  173.     FBarcode.ColorBK    := Value;
  174.   Picture.Graphic    := FBarcode.GetBitmap;
  175.     Invalidate;
  176. End;
  177. Function TQRDuckBarcode.GetColorBK: TColor;
  178. Begin
  179.     Result    := FBarcode.ColorBK;
  180. End;
  181. Procedure TQRDuckBarcode.SetFont (Const Value: TFont);
  182. Begin
  183.     FBarcode.Font    := Value;
  184.   Picture.Graphic    := FBarcode.GetBitmap;
  185.     Invalidate;
  186. End;
  187. Function TQRDuckBarcode.GetFont: TFont;
  188. Begin
  189.     Result    := FBarcode.Font;
  190. End;
  191. Procedure TQRDuckBarcode.SetOptions (Const Value: TBarcodeOptions);
  192. Begin
  193.     FBarcode.Options    := Value;
  194.   Picture.Graphic    := FBarcode.GetBitmap;
  195.     Invalidate;
  196. End;
  197. Function TQRDuckBarcode.GetOptions: TBarcodeOptions;
  198. Begin
  199.     Result    := FBarcode.Options;
  200. End;
  201. Procedure TQRDuckBarcode.SetAlignment (Const Value: TAlignment);
  202. Begin
  203.     FBarcode.Alignment    := Value;
  204.   Picture.Graphic    := FBarcode.GetBitmap;
  205.     Invalidate;
  206. End;
  207. Function TQRDuckBarcode.GetAlignment: TAlignment;
  208. Begin
  209.     Result    := FBarcode.Alignment;
  210. End;
  211. Procedure TQRDuckBarcode.SetBarWidth (Const Value: Double);
  212. Begin
  213.     FBarcode.BarWidthMM    := Value;
  214.   Picture.Graphic    := FBarcode.GetBitmap;
  215.     Invalidate;
  216. End;
  217. Function TQRDuckBarcode.GetBarWidth: Double;
  218. Begin
  219.     Result    := FBarcode.BarWidthMM;
  220. End;
  221. Procedure TQRDuckBarcode.SetPicture(Value: TPicture);
  222. Begin
  223.   FPicture.Assign(Value);
  224. End;
  225. {
  226. Procedure TQRDuckBarcode.Paint;
  227. Var
  228.     R:                TRect;
  229. Begin
  230.     With Canvas Do
  231.   Begin
  232.         Brush.Color    := ColorBK;
  233.         Pen.Color    := clBlack;
  234.      Pen.Style    := psSolid;
  235.       Rectangle(0, 0, Width - 1, Height - 1);
  236.      if not Picture.Graphic.Empty Then
  237.      Begin
  238.             SetRect(R, 1, 1, Picture.Width, Picture.Height);
  239.             OffsetRect(R, (ClientWidth - Picture.Width) div 2,
  240.             (ClientHeight - Picture.Height) div 2);
  241.             StretchDraw (R, Picture.Graphic);
  242.      End;
  243.   End;
  244. End;
  245. }
  246. Procedure TQRDuckBarcode.Paint;
  247. Var
  248.     R:                TRect;
  249.     Field:        TField;
  250. Begin
  251.     Field    := nil;
  252.     if FDataSet <> nil Then
  253.       if FDataSet.Active Then
  254.          if FDataField <> '' Then
  255.               Field    := FDataSet.FieldByName (FDataField);
  256.  
  257.     With Canvas Do
  258.   Begin
  259.         Brush.Color    := ColorBK;
  260.         Pen.Color    := clBlack;
  261.      Pen.Style    := psSolid;
  262.       Rectangle(0, 0, Width - 1, Height - 1);
  263.      if Field <> nil Then
  264.          FBarcode.Text    := Field.AsString
  265.      Else
  266.          FBarcode.Text        := '0123456789012';
  267.      SetRect(R, 1, 1, Picture.Width, Picture.Height);
  268.         FBarcode.PaintRectQReport (Canvas, R);
  269.   End;
  270. End;
  271. Procedure TQRDuckBarcode.Print(OfsX, OfsY : integer);
  272. Var
  273.     CalcLeft,
  274.     CalcTop,
  275.     CalcRight,
  276.     CalcBottom : Longint;
  277.   Field:        TField;
  278. Begin
  279.     Field    := nil;
  280.     if FDataSet <> nil Then
  281.       if FDataSet.Active Then
  282.          if FDataField <> '' Then
  283.               Field    := FDataSet.FieldByName (FDataField);
  284.     With ParentReport.QRPrinter Do
  285.     Begin
  286.         CalcLeft        := XPos(OfsX + Size.Left);
  287.         CalcTop        := YPos(OfsY + Size.Top);
  288.         CalcRight    := XPos(OfsX + Size.Left + Size.Width);
  289.         CalcBottom    := YPos(OfsY + Size.Top + Size.Height);
  290.         FBarcode.Text    := Field.AsString;
  291.         FBarcode.PaintRectQReport (Canvas,
  292.             Rect (CalcLeft, CalcTop, CalcRight, CalcBottom));
  293.     End;
  294. End;
  295.  
  296. End.
  297.